{-# OPTIONS -Wall #-}

--------------------------------------------------------------------------------
-- |
-- Module      :  Lirio.Base.LyPrims
-- Copyright   :  (c) Stephen Tetley 2012
-- License     :  BSD3
--
-- Maintainer  :  Stephen Tetley <stephen.tetley@gmail.com>
-- Stability   :  highly unstable
-- Portability :  GHC
--
-- Primitive LilyPond Docs. 
--
-- The primtives are context free - they do not directly 
-- accommodate relative pitch or relative duration.
--
-- Capital D suffix indicates the function generates a 
-- (wl-pprint) Doc.
--
-- Capital C suffix indicates the function generates a CatDoc.
--
-- Capital T suffix idicates the function is a CatDoc transformer.
--
--------------------------------------------------------------------------------


module Lirio.Base.LyPrims
  (

    commandD
  , pitchD
  , pitchLetterD
  , pitchLabelD

  , accidentalD
  , durationD

  , commandC
  , genericEventC
  , genericMarkC

  , noteC
  , chordC
  , restC
  , spacerC

  , lbeamT
  , rbeamT
  , lslurT
  , rslurT


  ) where

import Lirio.Base.CatDoc
import Lirio.Base.Duration
import Lirio.Base.Pitch

import Text.PrettyPrint.Leijen                  -- package: wl-pprint




commandD :: String -> Doc
commandD ss = text $ '\\' : ss


pitchD :: Pitch -> Doc
pitchD (Pitch l oa o) = 
    group (pitchLetterD l <> maybe empty accidentalD oa <> ove o)
  where
    ove i | i > 0       = text $ replicate i       '\''
          | i < 0       = text $ replicate (abs i) ','
          | otherwise   = empty



pitchLetterD :: PitchLetter -> Doc
pitchLetterD C = char 'c'
pitchLetterD D = char 'd'
pitchLetterD E = char 'e'
pitchLetterD F = char 'f'
pitchLetterD G = char 'd'
pitchLetterD A = char 'a'
pitchLetterD B = char 'b'

pitchLabelD :: PitchLabel -> Doc
pitchLabelD (PitchLabel p Nothing)  = pitchLetterD p
pitchLabelD (PitchLabel p (Just a)) = pitchLetterD p <> accidentalD a



accidentalD :: Accidental -> Doc
accidentalD DoubleFlat    = text "eses"
accidentalD Flat          = text "es"
accidentalD Nat           = empty
accidentalD Sharp         = text "is"
accidentalD DoubleSharp   = text "isis"


durationD :: Duration -> Doc
durationD dn = 
    let (n,dc) = components dn in numeral n <> dots dc
  where
    numeral N128  = int 128
    numeral N64   = int 64
    numeral N32   = int 32
    numeral N16   = int 16
    numeral N8    = int 8
    numeral N4    = int 4
    numeral N2    = int 2
    numeral N1    = int 1
    numeral Breve = commandD "breve"
    numeral Longa = commandD "longa"

    dots n        | n < 0     = empty
                  | otherwise = text $ replicate n '.'



commandC :: String -> CatDoc
commandC = typomark . commandD

genericEventC :: Doc -> Maybe Duration -> CatDoc
genericEventC evt (Nothing) = plainNote $ evt
genericEventC evt (Just d)  = plainNote $ evt <> durationD d

genericMarkC :: Doc -> CatDoc
genericMarkC = typomark


noteC :: Pitch -> Maybe Duration -> CatDoc
noteC p (Nothing) = plainNote $ pitchD p
noteC p (Just d)  = plainNote $ pitchD p <> durationD d

chordC :: [Pitch] -> Maybe Duration -> CatDoc
chordC ps (Nothing) = plainNote $ angles (hsep $ map pitchD ps)
chordC ps (Just d)  = plainNote $ angles (hsep $ map pitchD ps) <> durationD d


restC :: Maybe Duration -> CatDoc
restC (Nothing) = plainNote $ char 'r'
restC (Just d)  = plainNote $ char 'r' <> durationD d


spacerC :: Maybe Duration -> CatDoc
spacerC (Nothing) = plainNote $ char 's'
spacerC (Just d)  = plainNote $ char 's' <> durationD d


lbeamT :: CatDoc -> CatDoc 
lbeamT = prefix lbracket

rbeamT :: CatDoc -> CatDoc
rbeamT = suffix rbracket

lslurT :: CatDoc -> CatDoc
lslurT = prefix lparen

rslurT :: CatDoc -> CatDoc
rslurT = prefix rparen

